home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / runtime / dynamic-prims.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.8 KB  |  130 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; Support for dynamic typing
  3.  
  4. (define (gather-instances)
  5.  (let ((l '()))
  6.   (table-for-each
  7.    (lambda (mname m)
  8.      (declare (ignore mname))
  9.      (when (eq? (module-type m) 'standard)
  10.     (setf l (append (haskell-list->list/identity
  11.              (eval-haskell-var (module-instance-var m)))
  12.             l))))
  13.    *modules*)
  14.   l))
  15.  
  16. (define (prim-all-instances x)
  17.   (declare (ignore x))
  18.   (gather-instances))
  19.  
  20. ;;; This is used to get around the Haskell type system.
  21.  
  22. (define (prim-apply f x)
  23.   (funcall f (box x)))
  24.  
  25. (define (prim-apply-list f xs)
  26.   (if xs (apply f (map (lambda (x) (box x)) xs)) f))
  27.  
  28. (define (prim-from-magic x) x)
  29.  
  30. (define (prim-to-magic x) x)
  31.  
  32.  
  33. ;;; Stuff for runtime coercion of overloaded values:
  34.  
  35. (define (prim-make-vars n)
  36.   (let ((res '()))
  37.     (dotimes (i n)
  38.       (declare (ignorable i))
  39.       (push (gensym "v") res))
  40.     res))
  41.  
  42. ;;;  DANGER   DANGER!   The following functions make assumptions about low
  43. ;;;  level representations.  If representations are changed these must be
  44. ;;;  updated!
  45.  
  46. ;;; Tuple support
  47.  
  48. (define (prim-get-tuple-constructor i)
  49.   (let ((s '()))
  50.     (dotimes (j i)
  51.       (declare (ignorable j))
  52.       (push '#f s))
  53.     (make-tuple-constructor i s)))
  54.  
  55. (define (prim-get-tuple-selector size i)
  56.   (if (eqv? size 2)
  57.       (if (eqv? i 0)
  58.       (function force-car/force)
  59.       (function force-cdr/force))
  60.       (lambda (x)
  61.     (force-vector-ref/force x i))))
  62.   
  63. (define (get-tuple-flags v s)
  64.   (if (null? (cdr s))
  65.       (or (car s) (car v))
  66.       (if (pair? v)
  67.       (list (or (car s) (car (car v))) (or (cadr s) (car (cdr v))))
  68.       (let ((i -1))
  69.         (map (lambda (e)
  70.            (setf i (1+ i))
  71.            (or e (car (vector-ref v i))))
  72.          s)))))
  73.  
  74. (define (get-struct-flags v s)
  75.   (let ((i 0))
  76.     (map (lambda (e)
  77.        (setf i (1+ i))
  78.        (or e (car (vector-ref v i))))
  79.      s)))
  80.  
  81. ;;; Support for manipulation of arbitrary values
  82.  
  83. (define (d-make-tuple-constr a s)
  84.   (make-tuple-constructor a s))
  85.  
  86. (define (d-make-constr i a s)
  87.   (make-tagged-data-constructor i a s))
  88.  
  89. (define (d-make-tuple-sel i a s)
  90.   (cond ((eqv? a 1)
  91.      (if s
  92.          (lambda (x) (force x))
  93.          (lambda (x) (force (force x))))) ; There are two wrappers!!
  94.     ((eqv? a 2)
  95.      (if (eqv? i 0)
  96.          (if s
  97.          (lambda (x) (car (force x)))
  98.          (lambda (x) (force (car (force x)))))
  99.          (if s
  100.          (lambda (x) (cdr (force x)))
  101.          (lambda (x) (force (cdr (force x)))))))
  102.     (else
  103.      (if s
  104.          (lambda (x)
  105.            (vector-ref (the vector (force x)) (the fixnum i)))
  106.          (lambda (x)
  107.            (force (vector-ref (the vector (force x)) (the fixnum i))))))))
  108.  
  109. (define (d-make-sel i a s)
  110.   (declare (ignore a))
  111.   (if s
  112.       (lambda (x)
  113.     (vector-ref (the vector (force x)) (1+ (the fixnum i))))
  114.       (lambda (x)
  115.     (force (vector-ref (the vector (force x)) (1+ (the fixnum i)))))))
  116.   
  117. (define (d-make-enum-constr i)
  118.   i)
  119.  
  120. (define (d-enum-type-to-int i)
  121.   i)
  122.  
  123. (define (d-tuple-type-to-int i)
  124.   (declare (ignore i))
  125.   0)
  126.  
  127. (define (d-type-to-int i)
  128.   (constructor-number i))
  129.  
  130.